home *** CD-ROM | disk | FTP | other *** search
/ The X-Philes (2nd Revision) / The X-Philes Number 1 (1995).iso / xphiles / hp48hor2 / digi24.src < prev    next >
Text File  |  1994-01-04  |  4KB  |  180 lines
  1. %%HP: T(3)A(D)F(.);
  2. @ Digi24 by Rodger Rosenbaum
  3. DIR
  4.   PeVAL
  5.     \<< \-> c x
  6.       \<< 'c(1)' EVAL 0 c SIZE OBJ\-> DROP 2 SWAP
  7.         FOR i x 0 MUL2 'c(i)' EVAL 0 ADD2
  8.         NEXT +
  9.       \>>
  10.     \>>
  11.   GAUS
  12.     \<< AUGM ELIM BACK
  13.     \>>
  14.   AUGM
  15.     \<< TRN \->STR
  16.       1 OVER SIZE 1 - SUB SWAP TRN \->STR
  17.       2 OVER SIZE SUB + STR\-> TRN MAKE
  18.     \>>
  19.   LOOK
  20.     \<< DEPTH 1 + 2 / DUP ROT - SWAP \-> a b
  21.       \<< a PCK b GET SWAP b GET SWAP SHO2
  22.       \>>
  23.     \>>
  24.   QAD
  25.     \<< SWAP 2 / NEG \-> a c b
  26.       \<< b 0 DUP2 MUL2 a 0 c 0 MUL2 SUB2 SQR2 +
  27.         b SIGN DUP 0 == + * b + DUP a /
  28.         IF DUP TYPE 1 \=/
  29.         THEN c ROT
  30.           IF DUP 0 ==
  31.           THEN SWAP DROP
  32.           ELSE /
  33.           END
  34.         ELSE SWAP DROP DUP CONJ
  35.         END
  36.       \>>
  37.     \>>
  38.   BACK
  39.     \<< DEPTH 2 / \-> s
  40.       \<< s 2
  41.         FOR x x UNIT x 1 - 1
  42.           FOR y x y RED -1
  43.           STEP -1
  44.         STEP
  45.       \>> 2000 .25 BEEP
  46.     \>>
  47.   ELIM
  48.     \<< DEPTH 2 / DUP 1 + 'SIZ' STO \-> s
  49.       \<< 1 s 1 -
  50.         FOR x SIZ x - PIVX x UNIT s x 1 +
  51.           FOR y x y RED -1
  52.           STEP
  53.         NEXT
  54.       \>> 2000 .25 BEEP
  55.     \>>
  56.   MAKE
  57.     \<< \->STR 2 OVER SIZE 1 - SUB STR\-> DEPTH 1 SWAP
  58.       START DEPTH ROLL DUP 0 *
  59.       NEXT
  60.     \>>
  61.   UNIT
  62.     \<< DUP SIZ SWAP - 2 * \-> s r
  63.       \<< r ROLL r ROLL DUP2 s GET SWAP s GET SWAP DIV2 r ROLLD r ROLLD
  64.       \>>
  65.     \>>
  66.   RED
  67.     \<< \-> r s
  68.       \<< SIZ s - PCK r GET SWAP r GET SIZ r - SIZ s - 2 *
  69.       \>> \-> b a r s
  70.       \<< r PCK s 2 + ROLL s 2 + ROLL SWP2 a b MUL2 SUB2 s ROLLD s ROLLD
  71.       \>>
  72.     \>>
  73.   PIV
  74.     \<< DUP 2 * SIZ ROT - \-> q s
  75.       \<< q 2 - 1
  76.         FOR r q PICK s GET ABS r 1 + PICK s GET ABS
  77.           IF <
  78.           THEN r q EXG
  79.           END -2
  80.         STEP
  81.       \>>
  82.     \>>
  83.   PIVX
  84.     \<< DUP 2 * SIZ ROT - \-> q s
  85.       \<< q DUP 1 + PICK s GET ABS q 2 - 1
  86.         FOR r r 2 + PICK s GET ABS DUP2
  87.           IF <
  88.           THEN ROT ROT DROP2 r SWAP
  89.           ELSE DROP
  90.           END -2
  91.         STEP DROP q DUP2
  92.         IF \=/
  93.         THEN EXG 1000 .1 BEEP
  94.         ELSE DROP2
  95.         END
  96.       \>>
  97.     \>>
  98.   EXG
  99.     \<< DUP2
  100.       IF >
  101.       THEN SWAP
  102.       END \-> u v
  103.       \<< u ROLL u ROLL v ROLL v ROLL SWP2 v ROLLD v ROLLD u ROLLD u ROLLD
  104.       \>>
  105.     \>>
  106.   SUB2
  107.     \<< \-> x x1 y y1
  108.       \<< x y - DUP x OVER - DUP y - x 4 ROLL 4 ROLL + - + x1 + y1
  109.         -
  110.         SWAP DUP2 + DUP 4 ROLLD - +
  111.       \>>
  112.     \>>
  113.   ADD2
  114.     \<< \-> x x1 y y1
  115.       \<< x y + DUP x OVER - DUP y + x 4 ROLL 4 ROLL + - + x1 + y1
  116.         +
  117.         SWAP DUP2 + DUP 4 ROLLD - +
  118.       \>>
  119.     \>>
  120.   DIV2
  121.     \<< \-> x x1 y y1
  122.       \<< x y / DUP DUP y MUL x ROT - SWAP - x1 + SWAP y1 * - y
  123.         /
  124.         SWAP DUP2 + DUP 4 ROLLD - +
  125.       \>>
  126.     \>>
  127.   MUL2
  128.     \<< \-> x x1 y y1
  129.       \<< x y MUL x y1 * x1 y * + + SWAP DUP2 + DUP 4 ROLLD - +
  130.       \>>
  131.     \>>
  132.   SQR2
  133.     \<< OVER
  134.       IF DUP ABS 0 \=/
  135.       THEN \v/ DUP DUP MUL 5 ROLL ROT - SWAP - ROT + .5 *
  136.         OVER / DUP 3 PICK + DUP 4 ROLL SWAP - ROT +
  137.       ELSE SWAP DROP
  138.       END
  139.     \>>
  140.   SHO2
  141.     \<< DUP2
  142.       IF DUP 0 \=/
  143.       THEN SIGN DUP 0 == + SWAP SIGN DUP 0 == +
  144.         IF \=/
  145.         THEN OVER XPON 11 - ALOG 3 PICK SIGN * DUP 4 ROLL SWAP - 3 ROLLD +
  146.           IF DUP2 XPON SWAP XPON SWAP - 12 \=/
  147.           THEN DUP DUP XPON ALOG SWAP OVER / IP * ROT OVER + ROT ROT -
  148.           END
  149.         END
  150.       ELSE DROP2
  151.       END RCLF 11 SCI ROT ROT
  152.       IF DUP 0 \=/
  153.       THEN OVER XPON OVER XPON - 11 - "0000000000000" 1 ROT SUB
  154.       ELSE "0"
  155.       END 3 ROLLD SWAP \->STR SWAP ABS \->STR DUP 1 1 SUB SWAP 3 20 SUB + 1
  156.         OVER "E" POS 1 - SUB ROT SWAP + 2 13 SUB ROT STOF
  157.     \>>
  158.   Dup2
  159.     \<< DUP2
  160.     \>>
  161.   PCK
  162.     \<< 2 * DUP 1 + PICK SWAP PICK
  163.     \>>
  164.   OVR2
  165.     \<< 4 PICK 4 PICK
  166.     \>>
  167.   SWP2
  168.     \<< 4 ROLL 4 ROLL
  169.     \>>
  170.   MUL
  171.     \<< DUP2 * ROT ROT SPLT ROT SPLT \-> h1 t1 h2 t2
  172.       \<< h1 h2 * OVER - h1 t2 * + h2 t1 * + t1 t2 * +
  173.       \>>
  174.     \>>
  175.   SPLT
  176.     \<< DUP DUP 1000001 * DUP ROT - - SWAP OVER -
  177.     \>>
  178.   SIZ 6
  179. END
  180.